PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/shazam.exe/GMISC.IMP

Text File | 1992-09-01 | 11.0 KB | 341 lines

   {*******************************************************************

   GMISC.IMP

   *******************************************************************}
   {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

   DRIVE

   |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
   {===================================================================

   Use DOS "Parse Filename" to validate drive number.
   Does not access the drive.
   Does not correct for "phantom" floppy drives.

   ===================================================================}
function IsDosDrive ( DriveNum : byte ) : boolean ;
var
   FCB                       : array [ 1 .. 36 ] of byte ;
   FileName                  : array [ 1 .. 3 ] of char ;
   R                         : registers ;
begin
   IsDosDrive                := FALSE ;
   if DriveNum < 1 then EXIT ;
   if DriveNum > 26 then EXIT ;
   fillchar ( FCB, sizeof ( FCB ), 0 ) ;
   FileName                  := 'x:'#0 ;
   FileName [ 1 ]            := Chr ( DriveNum + 64 ) ;
   with R do
   begin
      AH                     := $29 ;
      AL                     := $00 ;
      DS                     := seg ( FileName ) ;
      SI                     := ofs ( FileName ) ;
      ES                     := seg ( FCB ) ;
      DI                     := ofs ( FCB ) ;
      MsDos ( R ) ;
      if AL = $FF then EXIT ;
   end ;
   IsDosDrive                := TRUE ;
end ;
   {===================================================================
                                                               DOS 3.1+
   IOCTL:  Check if block device is remote.
   NOTE:  DOS returns TRUE, even if the disk number is invalid.
          Use program logic or "IsDosDrive" to avoid invalid disks.
   ===================================================================}
function IsRemote ( DriveNum : byte ) : boolean ;
var
   Regs                      : registers ;
begin
   IsRemote                  := FALSE ;
   Regs.AH                   := $44 ;
   Regs.AL                   := $09 ;
   Regs.BL                   := DriveNum ;
   Regs.DX                   := 0 ;
   MsDos ( Regs ) ;
   if Regs.Flags and FCarry = 0 then
      if ( Regs.DX and $1000 ) <> 0 then   { Bit 12, 0=local 1=remote }
         IsRemote            := TRUE ;
end ;
   {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

   NETWORK

   |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
   {===================================================================

   16-character machine name; blank if not on net              DOS 3.0+

   ===================================================================}
function NetMachineName      : string ;
var
   S                         : string ;
   Regs                      : registers ;
begin
   NetMachineName            := '' ;
   FillChar ( S , SizeOf ( S ) , #32 ) ;
   S [ 0 ]                   := #16 ;
   S                         := S + #0 ;
   Regs.AX                   := $5E00 ;
   Regs.DS                   := seg ( S ) ;
   Regs.DX                   := ofs ( S ) + 1 ;
   Regs.CL                   := 0 ;
   Regs.CH                   := 0 ;
   MsDos ( Dos.Registers ( regs ) ) ;
   if Regs.CH = 0 then EXIT ;                     { Name not defined }
   if Regs.Flags and FCarry <> 0 then EXIT ;                 { Error }
   while S [ length ( S ) ]= #0 do
      delete ( S , length ( S ) , 1 ) ;                   { trim NUL }
   while S [ length ( S ) ] = #32 do
      delete ( S , length ( S ) , 1 ) ;                 { trim space }
   NetMachineName            := S ;
end;
   {===================================================================

   Return "0" for stand-alone, or up to 8 character name on network.

   ===================================================================}
function PcName              : string ;
var
   S                         : string ;
begin
   S                         := NetMachineName ;
   if length ( S ) > 8 then
      S [ 0 ]                := #8 ;
   if S = '' then
      S                      := '0' ;
   PcName                    := S ;
end ;
   {===================================================================

   SOUND - for past begin/end of file.

   ===================================================================}
procedure Buzz ;
begin
   sound ( 220 ) ;
   delay ( 200 ) ;
   nosound ;
end ;
   {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

   MEMORY

   |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
   {===================================================================

   ADDRESS - Return the address in bytes...

   ===================================================================}
function Address ( VAR A ) : longint ;
var
   L                         : longint ;
begin
   L                         := seg ( A ) ;
   L                         := L * 16 ;
   inc ( L , ofs ( A ) ) ;
   Address                   := L ;
end ;
   {===================================================================

   TRAPPED - Memory deallocated below "HeapPtr"

   ===================================================================}
function HeapTrapped : longint ;
begin
   HeapTrapped               := MemAvail - MaxAvail ;
end ;
   {===================================================================

   USED - Amount of allocated memory

   ===================================================================}
function HeapUsed : longint ;
begin
   HeapUsed                  := Address ( HeapPtr^ ) -
                                Address ( HeapOrg^ ) -
                                HeapTrapped ;
end ;
   {|||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||

   REDIRECTION

   |||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||||}
   {===================================================================

   Return TRUE if handle (0=input, 1=output) is console device

   ===================================================================}
function IsConsole ( Handle : word ) : boolean ;
var
   Regs                      : Registers ;
begin
   with Regs do
   begin
      AX                     := $4400 ;
      BX                     := Handle ;
      MsDos ( Regs ) ;
      if ( DX and $80 ) = 0 then
         IsConsole           := FALSE
      else
         IsConsole           := ( DX and $02 <> 0 ) or
                                ( DX and $01 <> 0 ) ;
   end;
end ;
   {===================================================================

   Return TRUE if
   1.  Input was redirected from the command-line.
   2.  The program has redirected input internally.

   ===================================================================}
function IsInputRedirected : boolean ;
begin
   IsInputRedirected         := not IsConsole ( DOS.TextRec ( Input ).Handle ) ;
end ;
   {===================================================================

   Return TRUE if
   1.  Output was redirected from the command-line.
   2.  The program has redirected output internally.

   ===================================================================}
function IsOutputRedirected : boolean ;
begin
   IsOutputRedirected        := not IsConsole ( DOS.TextRec ( Output ).Handle ) ;
end ;
   {===================================================================

   Reset "input" as text device.

   ===================================================================}
function RedirectInputTo ( S : string ) : boolean ;
begin
   RedirectInputTo           := FALSE ;
{$I-}
   Assign ( input , S ) ;
   if IOresult <> 0 then EXIT ;
   Reset ( input ) ;
   if IOresult <> 0 then EXIT ;
{$I+}
   RedirectInputTo           := TRUE ;
end ;
   {===================================================================

   Appends to "output" as text device.

   ===================================================================}
function RedirectOutputTo ( S : string ) : boolean ;
begin
   RedirectOutputTo          := FALSE ;
{$I-}
   close ( output ) ;
   if IOresult <> 0 then EXIT ;
   Assign  ( output , S ) ;
   if IOresult <> 0 then EXIT ;
   append ( output ) ;
   if IOresult <> 0 then
      rewrite ( output ) ;
   if IOresult <> 0 then EXIT ;
{$I+}
   RedirectOutputTo          := TRUE ;
   CRT.DirectVideo           := FALSE ;         { DesqView/syntax msg }
end ;
   {===================================================================

   Reassign input to CRT routines.

   ===================================================================}
function CancelRedirectInput : boolean ;
begin
   CancelRedirectInput       := FALSE ;
{$I-}
   Flush ( input ) ;
   if IOresult <> 0 then EXIT ;
   Close ( input ) ;
   if IOresult <> 0 then EXIT ;
   AssignCrt ( input )  ;
   if IOresult <> 0 then EXIT ;
   reset   ( input ) ;
   if IOresult <> 0 then EXIT ;
{$I+}
   CancelRedirectInput       := TRUE ;
end ;
   {===================================================================

   Reassign output to CRT routines.

   ===================================================================}
function CancelRedirectOutput : boolean ;
begin
   CancelRedirectOutput      := FALSE ;
{$I-}
   Flush ( output ) ;
   if IOresult <> 0 then EXIT ;
   Close ( output ) ;
   if IOresult <> 0 then EXIT ;
   AssignCrt ( output ) ;
   if IOresult <> 0 then EXIT ;
   rewrite ( output ) ;
   if IOresult <> 0 then EXIT ;
{$I+}
   CancelRedirectOutput      := TRUE ;
   CRT.DirectVideo           := TRUE ;          { DesqView/syntax msg }
end ;
   {===================================================================

   CHDIR change

   ===================================================================}
function CD ( S : string ) : boolean ;
begin
   S                         := FExpand ( S ) ;
   while ( S [ length ( S ) ] = '\' ) and
         ( length ( S ) > 3 ) do
         dec ( S[0] ) ;
{$I-}
   ChDir ( S ) ;
{$I+}
   CD                        := IOResult = 0 ;
end ;
   {===================================================================

   MD/MKDIR - with error check.

   ===================================================================}
function MD ( S : string ) : boolean ;
begin
   S                         := Fexpand ( S ) ;
   while ( S [ length ( S ) ] = '\' ) and
         ( length ( S ) > 3 ) do
         dec ( S[0] ) ;
   if DirExist ( S ) then
   begin
      MD                     := TRUE ;
      EXIT ;
   end ;
{$I-}
   MkDir ( S ) ;
{$I+}
   MD                        := IOResult = 0 ;
end ;
   {===================================================================

   RD/RMDIR - with error check.

   ===================================================================}
function RD ( S : string ) : boolean ;
begin
   S                         := Fexpand ( S ) ;
   while ( S [ length ( S ) ] = '\' ) and
         ( length ( S ) > 3 ) do
         dec ( S[0] ) ;
{$I-}
   RmDir ( S ) ;
{$I+}
   RD                        := IOResult = 0 ;
end ;